(FILECREATED " 7-NOV-73  5:18:20" S-TREE)


  (LISPXPRINT (QUOTE TREEVARS)
              T)
  (RPAQQ TREEVARS ((* The tree generator)
          (FNS GENRADLIST GENRADS GENRADD GENRAD GENMOL PERMRADS 
               PERMRADL)))

(* The tree generator)

(DEFINEQ

(GENRADLIST
  [LAMBDA (CLCL)
    (GROUPRADS (MAPCAR CLCL (FUNCTION (LAMBDA (X)
                           (CONS (GENRAD (CAR X))
                                 (CDR X])

(GENRADS
  [LAMBDA (CL N)
    (COND
      ((NULL CL)
        (LIST NIL))
      (T (FOR PARTITION IN (CLPARTITIONSN CL N 1 (CLCOUNT CL))
            JOIN (GENRADLIST (CLCREATE PARTITION])

(GENRADD
  [LAMBDA (CENTER NEWCL)
    (FOR DEGREE FROM 1 TO (MIN (CLCOUNT NEWCL)
                               (SUB1 (VALENCE CENTER)))
                         FOR RADCL
       IN (GENRADS NEWCL DEGREE)
       JOIN (PERMRADL CENTER RADCL T])

(GENRAD
  [LAMBDA (CL)
    (COND
      ((AND (NULL (CDR CL))
            (EQUAL (CDAR CL)
                   1))
        (PERMRADL (CAAR CL)
                  NIL T))
      (T (FOR OLDCL ON CL AS CENTER IS (CAAR OLDCL)
            AS NEWCL IS (CLDIFF CL (LIST (CONS CENTER 1)))
            JOIN (GENRADD CENTER NEWCL])

(GENMOL
  [LAMBDA (CL)
    (COND
      [(STRUCINCL CL)
        (LIST (CREATE FORM FN←(QUOTE GENMOL)
                      ARGS←(LIST CL]
      (T (PROG (MINDEG RESULT NATOMS)
               (COND
                 ((EQ (SETQ NATOMS (CLCOUNT CL))
                      1)
                   (RETURN (PERMRADL (CAAR CL)
                                     NIL NIL)))
                 ((EVENP NATOMS)
                   [for PART in (CLEQUALPARTS CL 2 (IQUOTIENT NATOMS 
                                                              2))
                      do (for RADS in (GENRADLIST (CLCREATE PART))
                            do (SETQ RESULT
                                 (APPEND (PERMRADL NIL RADS NIL)
                                         RESULT]
                   (SETQ MINDEG 3))
                 (T (SETQ MINDEG 2)))
               (SETQ NATOMS (SUB1 NATOMS))
               (FOR PAIR IN CL AS CENTER IS (CAR PAIR)
                  AS NEWCL IS (CLDIFF CL (LIST (CONS CENTER 1)))
                    FOR DEG
                  FROM MINDEG
                  TO (MIN (VALENCE CENTER)
                          NATOMS)
                    FOR P
                  IN (CLPARTITIONSN NEWCL DEG 1 (IQUOTIENT NATOMS 2))
                    FOR RADS
                  IN (GENRADLIST (CLCREATE P))
                  DO (SETQ RESULT (NCONC (PERMRADL CENTER RADS NIL)
                                         RESULT)))
               (RETURN RESULT])

(PERMRADS
  [LAMBDA (CENT CLRADS FLAG)
    (COND
      [(OR (STRUCFORM? CENT)
           (STRUCINCL CLRADS))
        (LIST (create FORM FN←(QUOTE PERMRAD)
                      ARGS←(LIST CENT CLRADS FLAG]
      ((ATOM CENT)
        (LIST (create RADICAL CENTER← CENT ATTACHEDRADS← CLRADS)))
      ((NOT (STRUCTURE? CENT))
        (LIST (create RADICAL CENTER←(create MAKECENTER RADSTRUC← 
                                             CENT)
                      ATTACHEDRADS← CLRADS)))
      (T (for ST in (LABELFV CENT ([LAMBDA (X)
                                 (COND
                                   (FLAG (CONS 1 X))
                                   (T X]
                               (CDRLIST CLRADS)))
            collect (create RADICAL CENTER←[create
                              MAKECENTER AFFLINK←(COND
                                (FLAG (CAAR (fetch LABELED of ST)))
                                (T NIL))
                              RADSTRUC←(fetch LSTRUC of ST)
                              CUFFLINKS←(COND
                                (FLAG (CDR (fetch LABELED of ST)))
                                (T (fetch LABELED of ST]
                            ATTACHEDRADS← CLRADS])

(PERMRADL
  [LAMBDA (CENT LRADS FLAG)
    (PERMRADS CENT (CLCREATE LRADS)
              FLAG])
)
STOP